home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr18
/
ter99.zip
/
PASCAL._XE
/
MAKEBBS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-04-28
|
6KB
|
213 lines
Program FilesBBSmaker;
{ This utility will search all the filelists specified in MAKEBBS.CFG }
{ for decriptions and create a FILES.BBS, usefull if you have a large }
{ download directory and you don't know the descriptions for the files }
{ Then this program will do al the work for you. 1993 by Bo Bendtsen }
{ Totally freeware, make any modifications you like, you remember to }
{ give some thanx or credits to me. }
Uses Crt,Dos;
Var
I,Out : Text;
Buf : Array[1..40960] of byte; { For reading textfiles faster }
Info : SearchRec;
Name : Array[1..1000] of String[12]; { Max 1000 filenames }
L,X,Y,left : Word;
Stop : Boolean;
C : Longint;
S,UPS : String;
StartPos,p : Byte;
Filelist : Array[1..20] of Record
F : String[60];
StartPos : Byte;
End;
Lister : Byte; { how many filelists }
Function GrabWord(S: String; B: Byte) : String;
Var st,e:Byte;
return : String[80];
Begin
Return:='';
st:=1;e:=1;
While B>0 Do
Begin
While (S[st]=' ') or (S[st]=#9) Do Inc(st); { #9 er TAB }
e:=st;
While (S[e]<>' ') And (e<=Length(s)) Do Inc(e);
Return:=Copy(S,st,e-st);
st:=e;
Dec(B);
End;
GrabWord:=Return;
End;
Function StrToInt(S: String) : LongInt;
Var
Kode : Integer;
i : LongInt;
b : Byte;
Begin
b:=Length(s);
While b>0 Do
Begin
If s[b] in [#0..#255]-['0'..'9'] Then Delete(s,b,1);
Dec(b);
End;
If Length(S) = 0 Then StrToInt := 0 Else Begin
Val(S,i,Kode);
If Kode = 0 Then StrToInt := i Else StrToInt := 0;
End;
End;
Function StUpcase(s:string):string;
Var i :byte;
Begin
for i := 1 to Length(s) do s[i] := UpCase(s[i]);
StUpcase:=s;
End;
Function BlankAfter(S : String; Len : Byte): String;
var
o : string;
SLen : Byte absolute S;
Begin
If Length(S) >= Len then BlankAfter := S
Else begin
o[0] := Chr(Len);
Move(S[1], o[1], SLen);
if SLen < 255 then FillChar(o[Succ(SLen)], Len-SLen, ' ');
BlankAfter := o;
End;
End;
Begin
TextAttr:=7; ClrScr; TextAttr:=16*7;
WriteLn('╒═════════════════════════════════════════════════════════════════════════════╕');
WriteLn('│ Filelist description searcher 1.00, made by Bo Bendtsen +45-42643827 │');
WriteLn('╘═════════════════════════════════════════════════════════════════════════════╛'#10);
TextAttr:=7;
If paramcount=0 Then
Begin
WriteLn('This program will read all files specified in a directory and search the');
WriteLn('for descriptions in the filelists specified in MAKEBBS.CFG');
WriteLn(#10'Syntax: MAKEBBS path+wildcard');
WriteLn( ' MAKEBBS C:\TERMINAT\DOWNLOAD\*.*');
WriteLn( ' MAKEBBS C:\TERMINAT\DOWNLOAD\*.GIF');
Halt;
End;
Assign(I,Copy(ParamStr(0),1,Length(ParamStr(0))-3)+'CFG');
{$I-} Reset(I); {$I+}
If IOResult<>0 Then
Begin
WriteLn('Unable to open config file');
Halt;
End;
Lister:=0; Fillchar(Filelist,sizeof(filelist),0);
While Not Eof(i) And (Lister<20) Do
Begin
ReadLn(I,S);
If (S<>'') And Not (S[1] in [';','%']) Then
Begin
Inc(Lister);
Filelist[Lister].F:=GrabWord(S,1);
Filelist[Lister].StartPos:=StrToInt(GrabWord(S,2));
If Filelist[Lister].StartPos=0 Then Filelist[Lister].StartPos:=1;
End;
End;
L:=0; Fillchar(Name,sizeof(name),0);
WriteLn('Reading files '+Paramstr(1));
FindFirst(Paramstr(1),Archive,Info);
While (DosError=0) And (L<1000) Do
Begin
If l mod 25=0 Then Write(#13,l);
Inc(L);
Name[L]:=Info.Name;
If Pos('.',Name[L])=0 Then Name[L]:=Name[L]+'.';
FindNext(Info);
End;
Left:=L;
If L=0 Then
Begin
WriteLn('No files to find');
Halt;
End;
Assign(Out,'FILES.BBS');
{$I-} Append(Out); {$I+}
If IOResult<>0 Then
Begin
{$I-} Rewrite(Out); {$I+}
If IOResult<>0 Then
Begin
WriteLn('Unable to write to FILES.BBS');
Halt;
End;
WriteLn(#13#10'Creating FILES.BBS');
End
Else WriteLn(#13#10'Appending to FILES.BBS');
For y:=1 to Lister Do
Begin
WriteLn(FileList[y].F);
Assign(I,FileList[y].F);
SetTextBuf(I,Buf);
{$I-} Reset(I); {$I+}
If IOResult<>0 Then WriteLn('Unable to open input file')
Else Begin
WriteLn(Out);
WriteLn(Out,' - MakeBBS : '+FileList[y].F);
WriteLn(Out);
StartPos:=Filelist[y].StartPos;
Stop:=False; C:=0;
While Not Eof(I) And Not Stop And (Left>0) Do
Begin
Inc(C);
If C Mod 100=0 Then
Begin
Stop:=KeyPressed;
Write(#13,'Lines: ',C,', missing ',Left,' ');
End;
ReadLn(I,S);
UPS:=StUpcase(S);
For x:=1 To L Do
Begin
If Pos(Name[x],UPS)=StartPos Then
Begin
Dec(Left);
WriteLn(Out,S);
Name[x]:='';
End
Else Begin
p:=Pos('.',Name[x]);
If Pos(Copy(Name[x],1,p-1),UPS)=StartPos Then
Begin
Dec(Left);
If Name[x][Length(Name[x])]='.' Then Name[x][0]:=Chr(Ord(Name[x][0])-1);
WriteLn(Out,BlankAfter(Name[x],12)+Copy(S,13,255));
Name[x]:='';
End
End;
End;
End;
WriteLn(#13#10'Lines processed: ',C);
Close(I);
End;
End;
Close(Out);
End.